#lang swindle

(require "seat.ss")
(require "position.ss")
(require "direction.ss")
(require "dice.ss")
(provide (all-defined))

(defclass <board> ()
  (dice :reader dice :initializer (thunk (make-hash-table 'equal)))
  (game :accessor game))

(defmethod (dice-list board)
  (hash-table-map (dice board) (lambda (pos die) die)))

(defmethod (size (board <board>)) 7)

(defmethod (location (board <board>) (pos <position>))
  (let* ((r (row pos)) (c (col pos)) (r-c (- r c))
	 (s (1- (size board))) (-s (- s)) (m (* 2 s)))
    (cond ((and (< 0 r m) (< 0 c m) (< -s r-c s)) (on-map))
	  ((and (= r 0) (= c s)) (make-gutter-corner 0))
	  ((and (= r s) (= c m)) (make-gutter-corner 1))
	  ((and (= r m) (= c m)) (make-gutter-corner 2))
	  ((and (= r m) (= c s)) (make-gutter-corner 3))
	  ((and (= r s) (= c 0)) (make-gutter-corner 4))
	  ((and (= r 0) (= c 0)) (make-gutter-corner 5))
	  ((= r 0)               (make-side-gutter 0))
	  ((= r-c -s)            (make-side-gutter 1))
	  ((= c m)               (make-side-gutter 2))
	  ((= r m)               (make-side-gutter 3))
	  ((= r-c s)             (make-side-gutter 4))
	  ((= c 0)               (make-side-gutter 5))
	  (else                  (off-board)))))

(defmethod (die-at (board <board>) (pos <position>))
  (ref (dice board) pos (thunk #f)))
(defmethod (set-die-at! (board <board>) (pos <position>) (die <die>))
  (hash-table-remove! (dice board) (position die))
  (hash-table-put! (dice board) pos die)
  (set! (board die) board)
  (set! (position die) pos))

(defmethod (next-position (die <die>) (dir <board-direction>))
  (next-position (position die) dir))
(defmethod (next-position (die <die>) (dir <gutter-direction>))
  (let* ((pos (position die))
	 (loc (location (board die) pos)))
    (next-position pos (board-direction loc dir))))

(define *initial-config*
  ;; row col size face
  ;; *seat1*
  '(((4 3 4 1)
     (5 5 4 1)
     (6 7 4 1)
     (7 9 4 1)
     (3 4 6 2)
     (4 6 6 2)
     (5 8 6 2)
     (2 5 8 3)
     (3 7 8 3))
    ;; *seat2*
    ((5 3 4 1)
     (6 5 4 1)
     (7 7 4 1)
     (8 9 4 1)
     (7 4 6 2)
     (8 6 6 2)
     (9 8 6 2)
     (9 5 8 3)
     (10 7 8 3))))

(defmethod (initialize (board <board>) initargs)
  (call-next-method)
  (loop-for (seat-config <- (getarg initargs :config *initial-config*)
			 and seat <- *seats*)
    (dolist (die-config seat-config)
      (let/match (row col size face) die-config
	(set! (die-at board (pos row col))
	      (make (die-class size) :owner seat :face face))))))

(defmethod (config (board <board>))
  (let ((seat-configs (make-hash-table)))
    (dolist (seat *seats*) (put! seat-configs null seat))
    (hash-table-for-each (dice board)
      (lambda (pos die)
	(push! (config die) (ref seat-configs (owner die)))))
    (list-of (ref seat-configs seat) (seat <- *seats*))))
